home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #005 (19xx)(Amiga User Group Deutschland e.V.).zip / Franz PD Disk #005 (19xx)(Amiga User Group Deutschland e.V.).adf / Bouncer / bouncer.src < prev   
Text File  |  1986-10-22  |  15KB  |  609 lines
  1. \ This is an example of hardware sprite animation
  2. \ using attached sprites.
  3. \ Jon Bryan:03-25-87
  4.  
  5. anew DemoMarker
  6. \ If DemoMarker exists, it and all subsequent words are
  7. \ forgotten and a new word DemoMarker is then created
  8. \ which does nothing.  Handy during development.
  9.  
  10. DECIMAL
  11.  
  12. 31415821    constant random.b
  13. 100000000   constant random.m
  14. here        variable random.seed random.seed !
  15.  
  16. : random  ( --- n1 )
  17.   random.seed  @ random.b m*
  18.   swap 1 + swap                      \ double numbers in low high format
  19.   random.m m/mod
  20.   drop
  21.   dup random.seed ! ;
  22.  
  23. : choose ( n1 --- n1 ) \ 
  24.   random m* random.m m/mod
  25.   swap drop ;
  26.  
  27. 256 CONSTANT ScanBufSize
  28. CREATE ScanBuf ScanBufSize ALLOT
  29.  
  30. : SpriteLine   ( -- addr1\addr2 )
  31.    ScanBuf ScanBufSize INFILE @ READ.TEXT 1- ( trim delim )
  32.    ScanBuf + DUP 16 - ;
  33.  
  34. : ?SpritePixel   ( character\base -- value )
  35.    DIGIT NOT  ERROR" Illegal Sprite Color" ;
  36.  
  37. : OR_SpritePlanes   ( number\address -- )
  38.    SWAP  2 /MOD     ( separate the two bits)
  39.    SWAP  16 SCALE   ( slide the low-order bit up a word)
  40.    OR               ( put them back together)
  41.    OVER @  2*       ( move the stored value one place left)
  42.    OR  SWAP !       ( and OR the new bits into place.) ;
  43.  
  44. : DoSimplePlanes   ( image\height -- )
  45.    0 DO  SpriteLine
  46.        DO  IC@ 4 ?SpritePixel OVER  OR_SpritePlanes
  47.        LOOP  4+
  48.    LOOP  DROP ;
  49.  
  50. : ImageSize   ( height -- height\#bytes )   DUP 4* 8+ ;
  51.  
  52. : Sprite   ( height -- )
  53.    ImageSize
  54.    CREATE  HERE
  55.      LOCALS|  image  size  height  |
  56.      size ALLOT  image size ERASE
  57.      image 4+ height  DoSimplePlanes ;
  58.  
  59. structure AttachedSprite
  60.    simpleSprite STRUCT:  +asEvenSprite
  61.    simpleSprite STRUCT:  +asOddSprite
  62. structure.end
  63.  
  64. : OR_AttachedPlanes   ( char\even sprite\odd sprite -- )
  65.    LOCALS|  odd  even  |
  66.    DUP 4/  odd OR_SpritePlanes    \ shift the two MSB's
  67.    3 AND  even OR_SpritePlanes ;  \ mask the two lowest bits
  68.  
  69. : aImageSize   ( height -- height\offset\total size )
  70.    ImageSize DUP 2* ;     \ for two sprites
  71.  
  72. : DoAttachedPlanes   ( image\height\offset -- )
  73.    LOCALS| offset |
  74.    0 DO  SpriteLine
  75.        DO  IC@ 16 ?SpritePixel   \ allows characters 0-F
  76.          OVER DUP offset +  OR_AttachedPlanes
  77.        LOOP   4+   \ increment the pointer 
  78.    LOOP  DROP ;
  79.  
  80. : Attached   ( height -- )
  81.    aImageSize
  82.    CREATE  HERE
  83.    LOCALS|  image  size  offset  height  |
  84.      offset 2+ W,      \ lay down offset to "attached" image
  85.      size ALLOT  image 2+ size ERASE     \ reserve the space
  86.      128 image 2+ offset + !             \ set "attach" bit
  87.      image 6+ height offset  DoAttachedPlanes ;
  88.  
  89. : +EvenImage   ( addr1 -- addr2 )   2+ ;
  90.  
  91. : +OddImage   ( addr1 -- addr2 )   DUP W@ + ;
  92.  
  93. struct AttachedSprite Ball
  94.   15 Ball +asEvenSprite +ssHeight W!
  95.   15 Ball +asOddSprite  +ssHeight W!
  96. structend
  97.  
  98. : MakeBall   ( name ( height -- )
  99.    Attached           \ CREATE is imbedded here
  100.    DOES>   ( -- )
  101.      ViewAddress +vViewPort @  SWAP 2DUP
  102.      Ball +asEvenSprite  SWAP +EvenImage  ChangeSprite
  103.      Ball +asOddSprite   SWAP +OddImage   ChangeSprite ;
  104.  
  105. \ The values for the following images were derived with a
  106. \ combination of an equation gleaned from "Graphics and Image
  107. \ Processing" by Theo Pavlidis and "Calibrated Eyeball."
  108.  
  109. 15 MakeBall 0Ball
  110.    0000007777000000
  111.    0000754444570000
  112.    00A6544334456A00
  113.    0086544334456800
  114.    0B876544445678B0
  115.    0B987665566789B0
  116.    ECA9877777789ACE
  117.    EDBA99888899ABDE
  118.    EEDCBBAAAABBCDEE
  119.    0FEEDCCCCCCDEEF0
  120.    0FFEEEEEEEEEEFF0
  121.    00FFFEEEEEEFFF00
  122.    00FFFFFFFFFFFF00
  123.    0000FFFFFFFF0000
  124.    000000FFFF000000
  125.  
  126. 15 MakeBall 1Ball
  127.    0000000000000000
  128.    0000087777800000
  129.    0009544334459000
  130.    00A6544334456A00
  131.    0097654444567900
  132.    0B987665566789B0
  133.    0DA9877777789AD0
  134.    0EBA99888899ABE0
  135.    0EDCBBAAAABBCDE0
  136.    0FEEDCCCCCCDEEF0
  137.    00FEEEEEEEEEEF00
  138.    00FFFEEEEEEFFF00
  139.    000FFFFFFFFFF000
  140.    00000FFFFFF00000
  141.    0000000000000000
  142.  
  143. 15 MakeBall 2Ball
  144.    0000000000000000
  145.    0000000000000000
  146.    0000009779000000
  147.    0000964334690000
  148.    0009654334569000
  149.    0009766556679000
  150.    00B9877777789B00
  151.    00CA99888899AC00
  152.    00ECBAAAAAABCE00
  153.    000EDDCCCCDDE000
  154.    000FEEEEEEEEF000
  155.    0000FFFFFFFF0000
  156.    000000FFFF000000
  157.    0000000000000000
  158.    0000000000000000
  159.  
  160. 15 MakeBall 3Ball
  161.    0000000000000000
  162.    0000000000000000
  163.    0000000000000000
  164.    0000009779000000
  165.    0000A743347A0000
  166.    0000965445690000
  167.    000A87777778A000
  168.    000CA988889AC000
  169.    000EDBAAAABDE000
  170.    0000EEEDDEEE0000
  171.    0000FFFFFFFF0000
  172.    000000FFFF000000
  173.    0000000000000000
  174.    0000000000000000
  175.    0000000000000000
  176.  
  177. 15 MakeBall 4Ball
  178.    0000000000000000
  179.    0000000000000000
  180.    0000000000000000
  181.    0000000000000000
  182.    0000009669000000
  183.    0000075335700000
  184.    0000976556790000
  185.    0000B987789B0000
  186.    0000EDBBBBDE0000
  187.    00000FEEEEF00000
  188.    000000FFFF000000
  189.    0000000000000000
  190.    0000000000000000
  191.    0000000000000000
  192.    0000000000000000
  193.  
  194. 15 MakeBall 5Ball
  195.    0000000000000000
  196.    0000000000000000
  197.    0000000000000000
  198.    0000000000000000
  199.    0000000000000000
  200.    0000009669000000
  201.    0000096336900000
  202.    00000B9779B00000
  203.    00000EDCCDE00000
  204.    000000FFFF000000
  205.    0000000000000000
  206.    0000000000000000
  207.    0000000000000000
  208.    0000000000000000
  209.    0000000000000000
  210.  
  211. \ The following word allows the creation of arrays of
  212. \ "execution vectors."
  213.  
  214. : VECTOR:   ( name ( -- )
  215.    [COMPILE] :
  216.    DOES>   ( n -- )
  217.      SWAP 2* + W@EXECUTE ;
  218.  
  219. VECTOR: ChangeBall   ( n -- )
  220.    0Ball 1Ball 2Ball 3Ball 4Ball 5Ball ;
  221.  
  222. struct SimpleSprite Shadow
  223.   18 Shadow +ssHeight W!
  224. structend
  225.  
  226. : MakeShadow   ( name ( height -- )
  227.    Sprite
  228.    DOES>   ( n -- )
  229.      ViewAddress +vViewPort @ Shadow ROT ChangeSprite ;
  230.  
  231. \ These simple sprites are a bit taller than the ball
  232. \ sprites.  That way they both use the same x,y
  233. \ coordinates and no offsets are necessary.
  234.  
  235. 18 MakeShadow 0Shadow
  236.    0000000000000000
  237.    0000000000000000
  238.    0000000000000000
  239.    0000000000000000
  240.    0000000000000000
  241.    0000000000000000
  242.    0000000000000000
  243.    0000000000000000
  244.    0000000000000000
  245.    0000000000000000
  246.    0000000000000000
  247.    0000000000000000
  248.    0000222222220000
  249.    0222222222222220
  250.    2222222222222222
  251.    2222222222222222
  252.    0222222222222220
  253.    0000222222220000
  254.  
  255. 18 MakeShadow 1Shadow
  256.    0000000000000000
  257.    0000000000000000
  258.    0000000000000000
  259.    0000000000000000
  260.    0000000000000000
  261.    0000000000000000
  262.    0000000000000000
  263.    0000000000000000
  264.    0000000000000000
  265.    0000000000000000
  266.    0000000000000000
  267.    0000022222200000
  268.    0022222222222200
  269.    0222222222222220
  270.    0022222222222200
  271.    0000022222200000
  272.    0000000000000000
  273.    0000000000000000
  274.  
  275. 18 MakeShadow 2Shadow
  276.    0000000000000000
  277.    0000000000000000
  278.    0000000000000000
  279.    0000000000000000
  280.    0000000000000000
  281.    0000000000000000
  282.    0000000000000000
  283.    0000000000000000
  284.    0000000000000000
  285.    0000000000000000
  286.    0000022222200000
  287.    0002222222222000
  288.    0022222222222200
  289.    0002222222222000
  290.    0000022222200000
  291.    0000000000000000
  292.    0000000000000000
  293.    0000000000000000
  294.  
  295. 18 MakeShadow 3Shadow
  296.    0000000000000000
  297.    0000000000000000
  298.    0000000000000000
  299.    0000000000000000
  300.    0000000000000000
  301.    0000000000000000
  302.    0000000000000000
  303.    0000000000000000
  304.    0000000000000000
  305.    0000000000000000
  306.    0000222222220000
  307.    0002222222222000
  308.    0000222222220000
  309.    0000000000000000
  310.    0000000000000000
  311.    0000000000000000
  312.    0000000000000000
  313.    0000000000000000
  314.  
  315. 18 MakeShadow 4Shadow
  316.    0000000000000000
  317.    0000000000000000
  318.    0000000000000000
  319.    0000000000000000
  320.    0000000000000000
  321.    0000000000000000
  322.    0000000000000000
  323.    0000000000000000
  324.    0000000000000000
  325.    0000022222200000
  326.    0000222222220000
  327.    0000022222200000
  328.    0000000000000000
  329.    0000000000000000
  330.    0000000000000000
  331.    0000000000000000
  332.    0000000000000000
  333.    0000000000000000
  334.  
  335. 18 MakeShadow 5Shadow
  336.    0000000000000000
  337.    0000000000000000
  338.    0000000000000000
  339.    0000000000000000
  340.    0000000000000000
  341.    0000000000000000
  342.    0000000000000000
  343.    0000000000000000
  344.    0000002222000000
  345.    0000022222200000
  346.    0000002222000000
  347.    0000000000000000
  348.    0000000000000000
  349.    0000000000000000
  350.    0000000000000000
  351.    0000000000000000
  352.    0000000000000000
  353.    0000000000000000
  354.  
  355. VECTOR: ChangeShadow   ( vector -- )
  356.    0Shadow 1Shadow 2Shadow 3Shadow 4Shadow 5Shadow ;
  357.  
  358. : FreeBall   ( -- )
  359.    Ball +asEvenSprite +ssNum W@ FreeSprite
  360.    Ball +asOddSprite  +ssNum W@ FreeSprite ;
  361.  
  362. : FreeShadow   ( -- )   Shadow +ssNum W@ FreeSprite ;
  363.  
  364. : Consecutive?   ( n\n -- )   - -1 = ;
  365.  
  366. : ?Balls   ( f -- )
  367.    Ball +asEvenSprite +ssNum W@
  368.    Ball +asOddSprite  +ssNum W@
  369.    Consecutive? NOT DUP
  370.    IF  Freeball FreeShadow  THEN
  371.    ERROR" Unable to allocate sprites" ;
  372.  
  373. : GetShadow   ( -- )
  374.    Shadow 7 GetSprite 7 = NOT DUP
  375.    IF  FreeShadow  THEN
  376.    ERROR" Unable to allocate sprites" ;
  377.  
  378. : GetBall   ( -- )
  379.    GetShadow
  380.    7 4 DO
  381.      Ball +asEvenSprite I    GetSprite  I =
  382.      Ball +asOddSprite  I 1+ GetSprite  I 1+ =  AND
  383.      IF  LEAVE  ELSE  FreeBall FreeShadow  THEN
  384.    2 +LOOP  ?Balls ;
  385.  
  386. \ Under 1.1 Kickstart, moving the even sprite moves them
  387. \ both, but according to reports that has changed on 1.2
  388.  
  389. : MoveBallSprite   ( x\y -- )
  390.    ViewAddress +vViewPort @
  391.    LOCALS|  viewport  y  x  |
  392.    viewport Ball +asEvenSprite  x y  MoveSprite
  393.    viewport Ball +asOddSprite   x y  MoveSprite ;
  394.  
  395. : MoveShadowSprite   ( x\y -- )
  396.    Viewaddress +vViewPort @  Shadow  2SWAP  MoveSprite ;
  397.  
  398. \ Executing this definition will set up the colors for the
  399. \ ball.  It will also change one color of the mouse cursor.
  400.  
  401. : 19-31.Greys   ( -- )   \ Only for registers 19 through 31
  402.    ViewAddress +vViewPort @  32
  403.    16 3 DO
  404.         1- 2DUP  I I I  SetRGB4
  405.    LOOP  2DROP ;
  406.  
  407. \ These values were derived from a combination of geometry
  408. \ and fudging them until they worked.
  409.  
  410. 15500 CONSTANT Xviewpoint
  411. 13200 CONSTANT Yviewpoint
  412.   500 CONSTANT Zmin
  413. 24575 CONSTANT Zmax    ( 4096 / will return a value 0-5 )
  414.   319 CONSTANT Xmin
  415. 38465 CONSTANT Xmax
  416.  1152 CONSTANT Ymin
  417. 11712 CONSTANT Ymax
  418. 19392 CONSTANT Xcenter
  419.  6400 CONSTANT Ycenter
  420.    64 CONSTANT Gravity
  421.    32 CONSTANT HalfGrav
  422.   128 CONSTANT TwoGrav
  423.    95 CONSTANT Spring
  424.       VARIABLE Zvel
  425.       VARIABLE Zpos
  426.       VARIABLE Xvel
  427.       VARIABLE Yvel
  428.  
  429. : Perspective   ( coord\center\viewpoint -- new coord )
  430.    LOCALS|  viewpoint  center  |
  431.    center -
  432.    viewpoint DUP Zpos @ + */
  433.    center + ;
  434.  
  435. : Ycrt   ( y -- y1 )
  436.    Ycenter Yviewpoint Perspective -6 SCALE ( 64 / ) ;
  437.  
  438. : Xcrt   ( x -- x1 )
  439.    Xcenter Xviewpoint Perspective -6 SCALE ;
  440.  
  441. : Zcrt   ( -- vector )   Zpos @ -12 SCALE ( 4096 / ) ;
  442.  
  443. : MoveBall   ( x\y -- x\y )
  444.    2DUP  LOCALS|  y  x  |
  445.    x Xcrt  Ymax Ycrt  OVER  y Ycrt  Zcrt DUP
  446.    WaitTOF  ChangeBall  ChangeShadow
  447.    MoveBallSprite  MoveShadowSprite ;
  448.  
  449. : ClipX   ( x\y -- x1\y )   SWAP Xmax MIN Xmin MAX SWAP ;
  450.  
  451. : ClipY   ( y -- y1 )   Ymax MIN Ymin MAX ;
  452.  
  453. : ClipZ   ( -- )   Zpos @ Zmax MIN Zmin MAX Zpos ! ;
  454.  
  455. : ClipToWindow   ( x\y -- x1\y1 )   ClipX ClipY ClipZ ;
  456.  
  457. : -YvelAdjust   ( y -- y )
  458.    Yvel @ DUP * OVER Ymin - TwoGrav * - SQRT NEGATE Yvel ! ;
  459.  
  460. : YvelAdjust   ( y -- y )
  461.    Yvel @ DUP * OVER Ymax - TwoGrav * - SQRT Yvel ! ;
  462.  
  463. : AdjustVelocity   ( y -- y )
  464.    DUP Ymin <              \ off the top of the screen
  465.    IF  -YvelAdjust
  466.    ELSE  DUP Ymax >        \ off the bottom
  467.      IF  YvelAdjust  THEN
  468.    THEN ;
  469.  
  470.     VARIABLE Yrem          \ Storage for velocity remainders
  471.     VARIABLE Xrem
  472.     VARIABLE Zrem
  473.     VARIABLE FrictionCoef  \ Friction parameters
  474. 999 CONSTANT Air           \ 0.1% friction loss in the air
  475. 990 CONSTANT Surface       \ 1.0% friction when rolling
  476.  
  477. : Friction   ( addr of remainder\velocity -- velocity1 )
  478.    1000 *                    \ Scale up the velocity
  479.    OVER @ +                  \ add the last remainder
  480.    FrictionCoef @  1000 */
  481.    1000 /MOD                 \ break out the new remainder
  482.    SWAP ROT ! ;              \ and save it away
  483.  
  484. : NewY   ( y -- y1 )
  485.    Yrem Yvel @  Friction  DUP Gravity + Yvel !
  486.    HalfGrav +  + AdjustVelocity ;
  487.  
  488. : NewX   ( x\y -- x1\y )
  489.    SWAP Xrem Xvel @  Friction  DUP Xvel !  +  SWAP ;
  490.  
  491. : NewZ   ( -- )
  492.    Zrem Zvel @  Friction  DUP Zvel !  Zpos @ + Zpos ! ;
  493.  
  494. : DoMove   ( x\y -- x1\y1 )
  495.    NewZ NewX NewY  ClipToWindow  MoveBall ;
  496.  
  497. : Blip ;   \ Just as soon as I figure out sound!
  498.  
  499. : Reflect   ( addr -- )
  500.    DUP @ Spring 100 */  NEGATE SWAP ! ;
  501.  
  502. : Enough?   ( addr -- f )   @ ABS  Halfgrav <  NOT ;
  503.  
  504. : Stopped?   ( y -- y\f )
  505.    DUP Ymax -  Xvel @ OR  Yvel @ OR  Zvel @ OR  NOT ;
  506.  
  507. : Front/Back   ( -- )
  508.    Zpos @ DUP Zmin = SWAP Zmax = OR
  509.    IF  Zvel Enough?
  510.      IF  Blip  THEN  Zvel Reflect
  511.    THEN ;
  512.  
  513. : Sides   ( x\y -- x\y )
  514.    OVER DUP Xmin = SWAP Xmax = OR
  515.    IF  Xvel Enough?
  516.      IF  Blip  THEN  Xvel Reflect
  517.    THEN ;
  518.  
  519. : Top/Bottom   ( y -- y )
  520.    DUP Ymin = OVER Ymax = OR
  521.    IF  Yvel Enough?
  522.      IF  Blip
  523.      ELSE  Surface FrictionCoef !
  524.      THEN  Yvel Reflect
  525.    THEN ;
  526.  
  527. : Bounce   ( x\y -- x\y )   Front/Back Sides Top/Bottom ;
  528.  
  529. : DrawBackground   ( -- )
  530.    GINIT  rport 1 SetApen ( same color as border )
  531.      2  10 moveto  201  69 drawto
  532.      2 188 moveto  201 128 drawto
  533.    637  10 moveto  438  69 drawto
  534.    637 188 moveto  438 128 drawto
  535.    438  69 drawto  201  69 drawto
  536.    201 128 drawto  438 128 drawto ;
  537.  
  538. \ define a custom screen with 2 bit planes
  539. struct NewScreen  BounceScreen
  540.    BounceScreen InitScreen   \ copy default values
  541.    2  BounceScreen +nsDepth W!  ( # bit planes )
  542.    CUSTOMSCREEN BounceScreen +nsType W!
  543. structend
  544.  
  545. \ A non-movable, non-sizable window
  546. struct NewWindow  BounceWindow
  547.    BounceWindow InitWindow   \ copies default values
  548.    0   BounceWindow +nwLeftEdge W!
  549.    8   BounceWindow +nwTopEdge  W!
  550.    640 BounceWindow +nwWidth    W!
  551.    190 BounceWindow +nwHeight   W!
  552.    WINDOWCLOSE ACTIVATE |  BounceWindow +nwFlags !
  553.    fCLOSEWINDOW  MOUSEBUTTONS |
  554.    BounceWindow +nwIDCMPFlags !
  555.    CUSTOMSCREEN BounceWindow +nwType W!
  556. structend
  557.  
  558. : CleanupBouncer ( -- )   \ do when fCLOSEWINDOW detected
  559.     FreeShadow FreeBall
  560.     CurrentWindow @ CloseWindow
  561.     CurrentScreen @ CloseScreen  ginit ;
  562.  
  563. : goodbye ( -- )  \ bye if executing turnkey, abort if not
  564.        ?turnkey  IF  bye  ELSE  abort  THEN ;
  565.  
  566. : BouncerEvents   ( -- )  \ process IDCMP events
  567.    GetEvent
  568.    CASE
  569.      fCLOSEWINDOW  OF  CleanupBouncer goodbye  ENDOF
  570.    ENDCASE ;
  571.  
  572. : InitVelocities   ( -- )
  573.    Air FrictionCoef !
  574.    0 Xrem ! 0 Yrem ! 0 Zrem !
  575.    8000 Choose Xvel !
  576.    4000 Choose Yvel !
  577.    4000 Choose Zvel ! ;
  578.  
  579. : Initialize
  580.    GetBall  Xmax Choose  Ymax Choose  ( first X and Y )
  581.    0"  Animation of an Attached Sprite in Multi-Forth "
  582.    BounceScreen +nsDefaultTitle !
  583.    BounceScreen OpenScreen  verifyscreen
  584.    CurrentScreen @ BounceWindow  +nwScreen !
  585.    BounceWindow OpenWindow  verifywindow
  586.    DrawBackground  19-31.Greys  ;
  587.  
  588. : Bouncer   ( -- )
  589.    Initialize
  590.    BEGIN  InitVelocities
  591.      BEGIN
  592.        BouncerEvents  DoMove Bounce Stopped?
  593.      UNTIL
  594.    AGAIN ;
  595.  
  596. : tst0   ( x\y -- )
  597.    initialize 2DROP
  598.    BEGIN  zmax 1+ zmin
  599.      DO  I zpos !  BouncerEvents MoveBall
  600.      10 +LOOP
  601.      zmin zmax
  602.      DO  I zpos !  BouncerEvents MoveBall
  603.      -10 +LOOP
  604.    AGAIN ;
  605.  
  606. : tst1   ( x\y -- )
  607.    initialize 2DROP  BEGIN  BouncerEvents MoveBall  AGAIN ;
  608.  
  609.